home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / blt1.000 / blt1 / blt-1.7-for-STk / demos / palette.stk < prev    next >
Encoding:
Text File  |  1994-07-26  |  10.5 KB  |  300 lines
  1. #!../test-blt -f
  2. ;;;; ----------------------------------------------------------------------
  3. ;;;;  PURPOSE:  color palette (demo for drag&drop facilities)
  4. ;;;;
  5. ;;;;   AUTHOR:  Michael J. McLennan       Phone: (215)770-2842
  6. ;;;;            AT&T Bell Laboratories   E-mail: aluxpo!mmc@att.com
  7. ;;;;
  8. ;;;; Rewritten for STk by Erick Gallesio
  9. ;;;;    Creation date:  6-Jul-1994 09:53
  10. ;;;; Last file update: 26-Jul-1994 10:51
  11. ;;;; ----------------------------------------------------------------------
  12. ;;;;            Copyright (c) 1993  AT&T  All Rights Reserved
  13. ;;;; ======================================================================
  14.  
  15. (require "blt")
  16. (require "dd-protocol")
  17.  
  18. (define DragDrop (make-hash-table))
  19. (define Red         0)
  20. (define Green       0)
  21. (define Blue        0)
  22.  
  23. ;;;; ----------------------------------------------------------------------
  24. ;;;; Routines for packaging token windows...
  25. ;;;; ----------------------------------------------------------------------
  26. (define (package-color color win)
  27.   (when (null? (winfo 'children win))
  28.     (pack (label (& win ".label") :text "Color")) :side "top")
  29.  
  30.   (let* ((rgb (winfo 'rgb *root* color))
  31.      (r   (quotient (car rgb)   256))
  32.      (g   (quotient (cadr rgb)  256))
  33.      (b   (quotient (caddr rgb) 256)))
  34.     
  35.     (tk-set! (string->widget (& win ".label")) :background color)
  36.     (tk-set! (string->widget (& win ".label")) :foreground (if (> (+ r g b) 384) "black" "white")))
  37.   color)
  38.  
  39. (define (package-number num win)
  40.   (when (null? (winfo 'children win))
  41.     (pack (label (& win ".label") :text "")) :side "top")
  42.  
  43.   (tk-set! (string->widget (& win ".label"))
  44.        :text (format #f "Number: ~A" (* num 1)))
  45.   num)
  46.  
  47. (define (package-text text win)
  48.   (when (null? (winfo 'children win))
  49.     (pack (label (& win ".label") :text "" :width 30)) :side "top")
  50.  
  51.   (tk-set! (string->widget (& win ".label")) :text (format #f "Text: ~A" text))
  52.   text)
  53.  
  54.  
  55. ;;;; ----------------------------------------------------------------------
  56. ;;;; Actions to handle color data...
  57. ;;;; ----------------------------------------------------------------------
  58. (define (hexa n)
  59.   (string-append (number->string (quotient n 16) 16) 
  60.          (number->string (modulo n 16) 16)))
  61.  
  62. (define (set-color . args)
  63.   (let ((rgb (winfo 'rgb *root* (hash-table-get DragDrop 'color ""))))
  64.     (if (or (null? args) (eq? (car args) 'red))
  65.     (set-red  (quotient (car rgb)   256)))
  66.     (if (or (null? args) (eq? args 'green))
  67.     (set-green  (quotient (cadr rgb)   256)))
  68.     (if (or (null? args) (eq? args 'blue))
  69.     (set-blue  (quotient (caddr rgb)   256)))))
  70.  
  71. (define (bg-color win)
  72.   (let* ((rgb  (winfo 'rgb *root* (hash-table-get DragDrop 'color "")))
  73.      (newR (quotient (car rgb)   256))
  74.      (newG (quotient (cadr rgb)  256))
  75.      (newB (quotient (caddr rgb) 256))
  76.      (actR (- newR 20))
  77.      (actG (- newG 20))
  78.      (actB (- newB 20))
  79.      (ncolor   (string-append "#" (hexa newR) (hexa newG) (hexa newB)))
  80.      (acolor   (string-append "#" (hexa actR) (hexa actG) (hexa actB)))
  81.      (children (winfo 'children win))
  82.      (win-name  (widget->string win)))
  83.  
  84.     (if (and (not (string-find? "sample" win-name)) 
  85.          (not (string=? win-name "*root*")))
  86.     (catch (begin
  87.          (tk-set! win :background ncolor)
  88.          (tk-set! win :activebackground acolor))))
  89.  
  90.     (for-each (lambda (x) (if (symbol-bound? x) (bg-color (eval x))))
  91.           (if (list? children) children (list children)))))
  92.  
  93. (define (fg-color win)
  94.   (let* ((rgb  (winfo 'rgb *root* (hash-table-get DragDrop 'color "")))
  95.      (newR (quotient (car rgb)   256))
  96.      (newG (quotient (cadr rgb)  256))
  97.      (newB (quotient (caddr rgb) 256))
  98.      (actR (- newR 20))
  99.      (actG (- newG 20))
  100.      (actB (- newB 20))
  101.      (ncolor   (string-append "#" (hexa newR) (hexa newG) (hexa newB)))
  102.      (acolor   (string-append "#" (hexa actR) (hexa actG) (hexa actB)))
  103.      (children (winfo 'children win))
  104.      (win-name  (widget->string win)))
  105.  
  106.     (if (and (not (string-find? "sample" win-name)) 
  107.          (not (string=? win-name "*root*")))
  108.     (catch (begin
  109.          (tk-set! win :foreground ncolor)
  110.          (tk-set! win :activeforeground acolor))))
  111.  
  112.     (for-each (lambda (x) (if (symbol-bound? x) (fg-color (eval x))))
  113.           (if (list? children) children (list children)))))
  114.  
  115.  
  116. ;;;; ----------------------------------------------------------------------
  117. ;;;; Setting color samples...
  118. ;;;; ----------------------------------------------------------------------
  119.  
  120. (define (update-main-sample)
  121.   (let ((color (string-append "#" (hexa Red) (hexa Green) (hexa Blue))))
  122.     (tk-set! .sample :background color)
  123.     (tk-set! .sample :foreground (if (> (+ Red Green Blue) 384) "black" "white"))))
  124.  
  125.  
  126. (define (set-red val)
  127.   (set! Red val)
  128.   (.red.cntl 'set val)
  129.   (tk-set! .red.sample :background (string-append "#" (hexa val) "0000"))
  130.   (update-main-sample))
  131.  
  132. (define (set-green val)
  133.   (set! Green val)
  134.   (.green.cntl 'set val)
  135.   (tk-set! .green.sample :background (string-append "#00" (hexa val) "00"))
  136.   (update-main-sample))
  137.  
  138. (define (set-blue val)
  139.   (set! Blue val)
  140.   (.blue.cntl 'set val)
  141.   (tk-set! .blue.sample :background (string-append "#0000" (hexa val)))
  142.   (update-main-sample))
  143.  
  144. ;;;; ----------------------------------------------------------------------
  145. ;;;; Main application window...
  146. ;;;; ----------------------------------------------------------------------
  147. (label '.sample :text "Color" :borderwidth 3 :relief 'raised)
  148.  
  149. (blt_drag&drop 'source .sample 'config
  150.            :packagecmd "package-color (format #f \"#~A~A~A\" (hexa Red) (hexa Green) (hexa Blue))")
  151.  
  152. (blt_drag&drop 'source .sample 'handler 'color 'dd-send-color)
  153. (blt_drag&drop 'target .sample 'handler 'color 'set-color)
  154.  
  155. (message '.explanation :font "-Adobe-times-medium-r-normal--*-120*"
  156.                 :aspect 200 
  157.                :text 
  158. "Press the third mouse button over a slider or a color sample and drag the token window around.  When the token becomes raised, it is over a target window.  
  159. Release the mouse button to drop the token and transfer information.  If the transfer fails, a \"no\" symbol is drawn on the token window.
  160. Try the following:
  161. - Drop a number from one slider onto another
  162. - Drop a color sample onto the Foreground/Background targets
  163. - Drop one of the slider color samples onto the main sample
  164. - Drop tokens from one palette application onto another")
  165.  
  166.  
  167. ;;;;
  168. ;;;; Color value entry...
  169. ;;;;
  170. (frame '.value :borderwidth 3)
  171. (label '.value.l :text "Color Value:")
  172. (entry '.value.e :borderwidth 2 :relief "sunken" :bg "white")
  173. (pack .value.l :side "left")
  174. (pack .value.e :side "left" :expand #t :fill 'x)
  175.  
  176. (blt_drag&drop 'source .value.e 'config
  177.            :packagecmd "package-color (.value.e 'get) ")
  178. (blt_drag&drop 'source .value.e 'handler 'color 'dd-send-color)
  179.  
  180. (blt_drag&drop 'target .value.e 'handler
  181.            'number '(begin
  182.               (.value.e 'delete 0 'end)
  183.               (.value.e 'insert 0 (hash-table-get DragDrop 'number)))
  184.            'color  '(begin
  185.               (.value.e 'delete 0 'end)
  186.               (.value.e 'insert 0 (hash-table-get DragDrop 'color))))
  187.  
  188. (bind .value.e "<Key-Return>" '(hash-table-put! DragDrop 
  189.                         'color 
  190.                         (.value.e 'get)))
  191.  
  192.  
  193. ;;;;
  194. ;;;; Red slider...
  195. ;;;;
  196. (frame '.red :borderwidth 3 :relief "raised")
  197. (scale '.red.cntl :label "Red" :orient "horiz" :from 0 :to 255 :command 'set-red)
  198. (frame '.red.sample :geometry "20x20" :borderwidth 3 :relief "raised")
  199. (pack .red.cntl :side "left" :expand #t :fill 'x)
  200. (pack .red.sample :side "right" :fill 'y)
  201.  
  202.  
  203. (blt_drag&drop 'source '.red.sample 'config
  204.            :packagecmd "package-color (format #f \"#~A0000\" (hexa Red)) ")
  205. (blt_drag&drop 'source '.red.sample 'handler 'color 'dd-send-color)
  206.  
  207. (blt_drag&drop 'target '.red.sample 'handler 
  208.            'number '(set-red (hash-table-get DragDrop 'number))
  209.            'color  '(set-color 'red))
  210.  
  211. (blt_drag&drop 'source '.red.cntl 'config 
  212.            :packagecmd "package-number [.red.cntl 'get] ")
  213. (blt_drag&drop 'source '.red.cntl 'handler 'number 'dd-send-number)
  214.  
  215. (blt_drag&drop 'target .red.cntl 'handler
  216.            'number '(set-red (hash-table-get DragDrop 'number))
  217.            'color  '(set-color 'red))
  218.  
  219. ;;;;
  220. ;;;; Green slider...
  221. ;;;;
  222. (frame '.green :borderwidth 3 :relief "raised")
  223. (scale '.green.cntl :label "Green" :orient "horiz" :from 0 :to 255 :command 'set-green)
  224. (frame '.green.sample :geometry "20x20" :borderwidth 3 :relief "raised")
  225. (pack .green.cntl :side "left" :expand #t :fill 'x)
  226. (pack .green.sample :side "right" :fill 'y)
  227.  
  228.  
  229. (blt_drag&drop 'source '.green.sample 'config
  230.            :packagecmd "package-color (format #f \"#00~A00\" (hexa Green)) ")
  231. (blt_drag&drop 'source '.green.sample 'handler 'color 'dd-send-color)
  232.  
  233. (blt_drag&drop 'target '.green.sample 'handler 
  234.            'number '(set-green (hash-table-get DragDrop 'number))
  235.            'color  '(set-color 'green))
  236.  
  237. (blt_drag&drop 'source '.green.cntl 'config 
  238.            :packagecmd "package-number [.green.cntl 'get] ")
  239. (blt_drag&drop 'source '.green.cntl 'handler 'number 'dd-send-number)
  240.  
  241. (blt_drag&drop 'target .green.cntl 'handler
  242.            'number '(set-green (hash-table-get DragDrop 'number))
  243.            'color  '(set-color 'green))
  244.  
  245.  
  246. ;;;;
  247. ;;;; Blue slider...
  248. ;;;;
  249. (frame '.blue :borderwidth 3 :relief "raised")
  250. (scale '.blue.cntl :label "Blue" :orient "horiz" :from 0 :to 255 :command 'set-blue)
  251. (frame '.blue.sample :geometry "20x20" :borderwidth 3 :relief "raised")
  252. (pack .blue.cntl :side "left" :expand #t :fill 'x)
  253. (pack .blue.sample :side "right" :fill 'y)
  254.  
  255.  
  256. (blt_drag&drop 'source '.blue.sample 'config
  257.            :packagecmd "package-color (format #f \"#0000~A\" (hexa Blue)) ")
  258. (blt_drag&drop 'source '.blue.sample 'handler 'color 'dd-send-color)
  259.  
  260. (blt_drag&drop 'target '.blue.sample 'handler 
  261.            'number '(set-blue (hash-table-get DragDrop 'number))
  262.            'color  '(set-color 'blue))
  263.  
  264. (blt_drag&drop 'source '.blue.cntl 'config 
  265.            :packagecmd "package-number [.blue.cntl 'get] ")
  266. (blt_drag&drop 'source '.blue.cntl 'handler 'number 'dd-send-number)
  267.  
  268. (blt_drag&drop 'target .blue.cntl 'handler
  269.            'number '(set-blue (hash-table-get DragDrop 'number))
  270.            'color  '(set-color 'blue))
  271. ;;;;
  272. ;;;; Foreground/Background color inputs...
  273. ;;;;
  274. (frame '.inputs)
  275. (label '.inputs.bg :text "Background" :borderwidth 3 :relief 'groove)
  276. (label '.inputs.fg :text "Foreground" :borderwidth 3 :relief 'groove)
  277. (button '.inputs.quit :text "Quit" :borderwidth 3 :command "exit")
  278.  
  279. (blt_drag&drop 'target .inputs.bg 'handler 'color '(bg-color *root*))
  280. (blt_drag&drop 'target .inputs.fg 'handler 'color '(fg-color *root*))
  281.  
  282. (pack .inputs.fg .inputs.bg :side "left" :padx 5 :pady 5)
  283. (pack .inputs.quit :side "right" :padx 5 :pady 5)
  284.  
  285. (pack 'append  *root*
  286.       .sample "top expand fillx filly" 
  287.       .explanation "top expand fillx filly" 
  288.       .value "top fillx" 
  289.       .red "top fill" 
  290.       .green "top fill" 
  291.       .blue "top fill" 
  292.       .inputs "top fillx")
  293.  
  294. (wm 'minsize *root* 200 200)
  295. (wm 'maxsize *root* 1000 1000)
  296.  
  297. (set-red 0)
  298. (set-green 0)
  299. (set-blue 0)
  300.